home *** CD-ROM | disk | FTP | other *** search
/ START Magazine / START VOL 4 NO 5.st / WORDPUZL.ARC / WORDPUZL.LST < prev    next >
Encoding:
File List  |  1989-09-10  |  30.3 KB  |  966 lines
  1. ' *****************************************************************************
  2. ' *                      WORD PUZZLE DESIGNER                                 *
  3. ' *                        BY EARL C. TOMAN                                   *
  4. ' *              Copyright 1989 Antic Publishing Company                      *
  5. ' *****************************************************************************
  6. ' * VARIABLES:                                                                *
  7. ' *   No_cols%          = Number of columns in puzzle                         *
  8. ' *   No_rows%          = Number of rows in puzzle                            *
  9. ' *   No_cells%         = Number of cells in puzzle                           *
  10. ' *   No_directions%    = Number of directions for words                      *
  11. ' *   Mx%               = Mouse x position
  12. ' *   My%               = Mouse y position
  13. ' *   Mb%               = Mouse buttons status
  14. ' *   Txtptr%           = Number of menu selection chosen by mouse click      *
  15. ' *   Colour%           = Fill colour in graphics title screen
  16. ' *   Crosshatch$       = "#"                                                 *
  17. ' *   Quotes$           = Double quote                                        *
  18. ' *   Space$            = Single space                                        *
  19. ' *   No_words%         = Number of words in puzzle                           *
  20. ' *   Old_no_word%      = Save area for No_words% during Edit_words routine   *
  21. ' *   Word_index%       = Calculated index into Words$() based on mouse posn  *
  22. ' *   Temp$             = Temporary text variable                             *
  23. ' *   Rez%              = Screen resolution                                   *
  24. ' *   Pass              = Pass counter when filling puzzle                    *
  25. ' *   Cell_ptr          = Pointer to current position in cell list            *
  26. ' *   Words_available   = Number of words available when filling puzzle       *
  27. ' *   Durection         = Direction to try when filling puzzle                *
  28. ' *   Sf!               = Swap flag used in sort (True if swap occurred)      *
  29. ' *   Pattern!          = Flag to indicate if pattern exists                  *
  30. ' *   Words!            = Flag to indicate if word list exists                *
  31. ' *   Wayflag!          = Flag to indicate if directions initialized          *
  32. ' *   Build!            = Flag to indicate if puzzle build needed             *
  33. ' *   Delete!           = Flag indicating word deletion during Edit_words     *
  34. ' * ARRAYS:                                                                   *
  35. ' *   Grid$(r,c)        = Puzzle grid                                         *
  36. ' *   Ri(n)             = Row increments that produce path directions         *
  37. ' *   Ci(n)             = Col increments that produce path directions         *
  38. ' *   Sequence(n)       = Sequence in which cells are examined                *
  39. ' *   Words$(n)         = The word list                                       *
  40. ' *   Store_words$(n)   = Holding array used to recopy Word$(n)               *
  41. ' *   Words_used(n)     = Keeps track of words used & where they are in puzzle*
  42. ' *   Words_unused(n)   = Lists unused words in descending order of length    *
  43. ' *****************************************************************************
  44. ' **** Check Screen Resolution ****
  45. Rez%=Xbios(4)        ! Hires = 2  Medres = 1  Lores = 0
  46. If Rez%=0
  47.   Cls
  48.   M$="YOUR SCREEN IS IN LOW RES.   |     PLEASE CHANGE TO|     MEDIUM RESOLUTION"
  49.   Alert 0,M$,1,"OK",Button%
  50.   End               ! Abort program to allow rez change
  51. Endif
  52. ' **** Draw Graphic Title Screen *********************************************
  53. Gosub Draw_title
  54. ' **** Program Inializations **************************************************
  55. Max_words%=80                ! Maximum of 80 words per puzzle
  56. Dim Words$(Max_words%)       ! Array for word list
  57. Dim Store_words$(Max_words%) ! Temporary holding area for Word$(n)
  58. Dim Strip$(60)       ! Menu bar choices
  59. Space$=" "
  60. Crosshatch$="#"
  61. Quotes$=Chr$(34)
  62. Pattern!=False      ! False when no pattern exists
  63. Words!=False        ! False when word list not initialized
  64. Build!=False        ! False when build needed
  65. No_directions%=8    ! Default to 8 directions
  66. Temp$=""            ! String corresponding to text of menu choice
  67. Gosub Init_directions ! Initialize direction arrays
  68. Wayflag!=True       ! Set flag to indicate directions initialized
  69. Cls
  70. Fullw 1             ! Opens window and set to full size of screen
  71. Gosub Main          ! Paint main menu bar, and initialize choices
  72. Menu 28,1           ! Show beginning default of 8 directions
  73. ' ******************* Beginning of Main Loop **********************************
  74. Do                  ! Loop allows menu items to be selected by mouse          *
  75.   Txtptr%=0         !                                                         *
  76.   On Menu           !                                                         *
  77.   Txtptr%=Menu(0)   ! Menu(0) is a number indicating menu choice              *
  78.   If Txtptr%<>0     !                                                         *
  79.     Gosub Main_menu_actions !                                                 *
  80.     Gosub Main      ! Repaint main menu bar, and init choices                 *
  81.   Endif             !                                                         *
  82. Loop                !                                                         *
  83. ' ********************** End of Main Loop *************************************
  84. '
  85. ' **** PROCEDURE MAIN - Paint main menu bar, and init choices *****************
  86. Procedure Main
  87.   Titlew 1," Word Puzzle Designer "
  88.   Restore Main_menu_bar_data
  89.   Gosub Build_menu_bar
  90.   If Words!<>True Or Pattern!<>True ! Disable Build Puzzle & Reprint Puzzle
  91.     Menu 31,2                       ! Choices if no word list or pattern
  92.     Menu 32,2
  93.   Endif
  94.   If Pattern!<>True   ! Disable all pattern choices except Create & Load Pattern
  95.     For I%=12 To 15   ! if no pattern has yet been initialized
  96.       Menu I%,2
  97.     Next I%
  98.   Else
  99.     Menu 11,2          ! Disable only Create Pattern choice if a pattern exists
  100.   Endif
  101.   If Words!<>True      ! Disable all Wordlist choices except New Words and
  102.     For I%=20 To 23    ! Load Words if no word list yet exists
  103.       Menu I%,2
  104.     Next I%
  105.   Endif
  106.   If Build!<>True
  107.     Menu 32,2
  108.   Endif
  109.   If No_directions%=8  ! Check mark in front of 8 directions
  110.     Menu 27,0
  111.     Menu 28,1
  112.   Else                 ! Check mark in front of 4 directions
  113.     Menu 27,1
  114.     Menu 28,0
  115.   Endif
  116. Return
  117. ' ******* PROCEDURE MAIN_MENU_ACTIONS ******************************************
  118. ' Purpose: Initiate appropriate subroutine as per main menu choice             *
  119. '
  120. Procedure Main_menu_actions
  121.   Menu Off            ! De-highlight chosen selection
  122.   Menu Kill
  123.   Temp$=Strip$(Txtptr%)
  124.   If Temp$=" Quit "
  125.     Closew 1
  126.     End               ! End the program
  127.   Endif
  128.   If Temp$=" Word Puzzle Designer "
  129.     Gosub Title
  130.   Endif
  131.   If Temp$=" Create "
  132.     Gosub Create_pattern
  133.   Endif
  134.   If Temp$=" Print "
  135.     Gosub Print_pattern
  136.   Endif
  137.   If Temp$=" Edit "
  138.     Gosub Chg_pattern
  139.   Endif
  140.   If Temp$=" New "
  141.     Gosub New_pattern
  142.   Endif
  143.   If Temp$=" Save "
  144.     Gosub Save_pattern
  145.   Endif
  146.   If Temp$=" Load "
  147.     Gosub Load_pattern
  148.   Endif
  149.   If Temp$=" New Wordlist "
  150.     Gosub Init_words
  151.   Endif
  152.   If Temp$=" Print Wordlist "
  153.     Gosub Print_wordlist
  154.   Endif
  155.   If Temp$=" Add Words "
  156.     Gosub Add_words
  157.   Endif
  158.   If Temp$=" Edit Wordlist "
  159.     Gosub Edit_words
  160.   Endif
  161.   If Temp$=" Save Wordlist "
  162.     Gosub Save_wordlist
  163.   Endif
  164.   If Temp$=" Load Wordlist "
  165.     Gosub Load_wordlist
  166.   Endif
  167.   If Temp$="  Four Directions " Or Temp$="  Eight Directions "
  168.     Gosub Init_directions
  169.   Endif
  170.   If Temp$=" Build Puzzle "
  171.     Gosub Build_puzzle
  172.   Endif
  173.   If Temp$=" Reprint Puzzle "
  174.     Gosub Print_puzzle
  175.   Endif
  176. Return
  177. ' ******* PROCEDURE TITLE ************************************************
  178. Procedure Title
  179.   Cls
  180.   Sound 1,14,3,4,4
  181.   Sound 1,0,0,0,4
  182.   Sound 1,14,3,4,4
  183.   Sound 1,0,0,0,4
  184.   Sound 1,14,3,4,4
  185.   Sound 1,0,0,0,4
  186.   Sound 1,14,11,3,16
  187.   Sound 1,0,0,0
  188.   M$="WORD PUZZLE DESIGNER v1.1|   A GFA Basic Program|      By Earl Toman| "+Chr$(189)+" 1989 Antic Publishing"
  189.   Alert 0,M$,1,"Return",Button%
  190. Return
  191. ' ******* PROCEDURE CREATE_PATTERN (of puzzle) *****************************
  192. Procedure Create_pattern
  193.   Cls
  194.   Repeat
  195.     Input "How many rows in the pattern (1-22)";No_rows%
  196.   Until No_rows%>=1 And No_rows%<=22
  197.   Repeat
  198.     Input "How many columns in the pattern (1-40)";No_cols%
  199.   Until No_cols%>=1 And No_cols%<=40
  200.   No_cells%=No_rows%*No_cols%
  201.   Dim Grid$(No_rows%,No_cols%),Sequence(No_cells%)       ! Dimension grid
  202.   Pattern!=True             ! Set flag to indicate a pattern exists
  203.   Gosub Erasegrid
  204.   Gosub Chg_pattern
  205. Return
  206. ' ******* PROCEDURE ERASEGRID (of puzzle) ********************************
  207. Procedure Erasegrid
  208.   Print "Erasing puzzle grid"
  209.   For J%=1 To No_rows%
  210.     For K%=1 To No_cols%
  211.       If Grid$(J%,K%)<>Space$
  212.         Grid$(J%,K%)=Crosshatch$
  213.       Endif
  214.     Next K%
  215.   Next J%
  216.   Cls
  217. Return
  218. ' ******* PROCEDURE INIT_WORDS *******************************************
  219. Procedure Init_words
  220.   Print At(1,1);"Enter Words.  Press RETURN on a new line to end the word list."
  221.   Print "              (Maximum word length allowed is 15 characters)"
  222.   No_words%=1
  223.   Do
  224.     Print "Word ";No_words%;": ";
  225.     Form Input 15,Words$(No_words%)
  226.     Exit If Words$(No_words%)=""
  227.     Words$(No_words%)=Upper$(Words$(No_words%))
  228.     Inc No_words%
  229.     If No_words%>Max_words%
  230.       Print
  231.       Print "***** WORD LIST FULL *****"
  232.       Pause 100
  233.     Endif
  234.     Exit If No_words%>Max_words%
  235.   Loop
  236.   Dec No_words%
  237.   Erase Words_used()
  238.   Erase Words_unused()
  239.   Dim Words_used(No_words%),Words_unused(No_words%)
  240.   If (No_words%>=1)
  241.     Words!=True
  242.   Endif
  243.   Clearw 1            ! Clear the window and then return
  244. Return
  245. ' ******* PROCEDURE PRINT_WORDLIST *****************************************
  246. Procedure Print_wordlist
  247.   Gosub Select_device
  248.   Clearw 1
  249.   Print #1,Tab(10);"*** WORD LIST CONTENTS ***"
  250.   Print
  251.   Gosub Print_word_list
  252.   If Dv=1
  253.     Print
  254.     Print "          < TO CONTINUE: CLICK MOUSE BUTTON, OR PRESS ANY KEY >"
  255.     Repeat
  256.       Button%=Mousek
  257.       Key$=Inkey$
  258.     Until (Button%=1 Or Button%=2) Or Key$<>""
  259.   Endif
  260.   Gosub Close_device
  261.   Clearw 1
  262. Return
  263. ' ******* PROCEDURE ADD_WORDS **************************************************
  264. Procedure Add_words
  265.   If No_words%>=Max_words%
  266.     Print
  267.     Print "***** WORD LIST FULL *****"
  268.     Pause 100
  269.   Else
  270.     Print At(1,1);"Enter Words.  Press RETURN on a new line to end the word list."
  271.     Print "              (Maximum word length allowed is 15 characters)"
  272.     Inc No_words%
  273.     Do
  274.       Print "Word ";No_words%;": ";
  275.       Form Input 15,Words$(No_words%)
  276.       Exit If Words$(No_words%)=""
  277.       Words$(No_words%)=Upper$(Words$(No_words%))
  278.       Inc No_words%
  279.       If No_words%>Max_words%
  280.         Print
  281.         Print "***** WORD LIST FULL *****"
  282.         Pause 100
  283.       Endif
  284.       Exit If No_words%>Max_words%
  285.     Loop
  286.     Dec No_words%
  287.     Build!=False        ! Force puzzle rebuild if words added
  288.     Erase Words_used()
  289.     Erase Words_unused()
  290.     Dim Words_used(No_words%),Words_unused(No_words%)
  291.   Endif
  292.   Clearw 1            ! Clear the window and then return
  293. Return
  294. ' ******* PROCEDURE EDIT_WORDS ************************************************
  295. Procedure Edit_words
  296.   Titlew 1," Edit Wordlist "
  297.   Restore Ed_menu_bar_data
  298.   Gosub Build_menu_bar
  299.   For I%=1 To Max_words%
  300.     Store_words$(I%)=""
  301.   Next I%
  302.   Delete!=False             ! No words deleted
  303.   Old_no_words%=No_words%   ! Save starting contents of No_words%
  304.   Display_words:
  305.   Row%=1                    ! Display word list
  306.   Col%=1
  307.   I%=1
  308.   While (I%<=Old_no_words%)
  309.     Print At(Col%,Row%);Words$(I%)
  310.     Col%=Col%+16
  311.     If (Col%>65)
  312.       Print
  313.       Row%=Row%+1
  314.       Col%=1
  315.     Endif
  316.     I%=I%+1
  317.   Wend
  318.   If Rez%=1                       ! If medium rez
  319.     Color 2                      !   Text color is red
  320.     Deftext 2,0,0,6
  321.     Box 0,152,639,199
  322.     Box 0,152,152,199
  323.     Line 8,170,128,170
  324.   Else                      ! High rez
  325.     Box 0,304,639,399
  326.     Box 0,304,152,399
  327.     Line 8,340,128,340
  328.   Endif
  329.   Print At(6,20);"EDIT WORD";
  330.   Print At(22,20);"** POINT TO THE DESIRED WORD WITH THE MOUSE POINTER **";
  331.   Print At(22,21);"**   PRESS LEFT MOUSE BUTTON TO EDIT THE WORD, OR   **";
  332.   Print At(22,22);"**  RIGHT MOUSE BUTTON TO DELETE/UNDELETE THE WORD  **";
  333.   If Rez%=1                  ! Back to black text
  334.     Color 1                  ! and lines
  335.     Deftext 1,0,0,6
  336.   Endif
  337.   Mb%=0
  338.   Do
  339.     On Menu
  340.     Temp$=Strip$(Menu(0))
  341.     Exit If Temp$=" Back to Main Menu "
  342.     If Temp$=" Word Puzzle Designer "
  343.       Menu Off
  344.       Gosub Title
  345.       Goto Display_words
  346.     Endif
  347.     Mouse Mx%,My%,Mb%
  348.     If (Mb%<>0)
  349.       Row%=(My%/(Rez%*8))+1
  350.       If (Mx%<125)           ! Calculate offset of selected word in Word$()
  351.         Col%=1
  352.         Word_index%=1+((Row%-1)*5)
  353.       Else
  354.         If (Mx%<253)
  355.           Col%=17
  356.           Word_index%=2+((Row%-1)*5)
  357.         Else
  358.           If (Mx%<381)
  359.             Col%=33
  360.             Word_index%=3+((Row%-1)*5)
  361.           Else
  362.             If (Mx%<509)
  363.               Col%=49
  364.               Word_index%=4+((Row%-1)*5)
  365.             Else
  366.               Col%=65
  367.               Word_index%=5+((Row%-1)*5)
  368.             Endif
  369.           Endif
  370.         Endif
  371.       Endif
  372.       If (Word_index%<=Old_no_words%)
  373.         If (Mb%=1)                                  ! Left mouse button pressed
  374.           Hidem                                     ! Hide mouse pointer
  375.           Print At(2,21);                           ! Edit word
  376.           Form Input 15 As Words$(Word_index%)
  377.           Words$(Word_index%)=Upper$(Words$(Word_index%))
  378.           Print At(2,21);"               ";
  379.           Print At(Col%,Row%);"                ";   ! Blank display field
  380.           Print At(Col%,Row%);Words$(Word_index%);  ! Display edited word
  381.           Showm                                     ! Display mouse pointer
  382.         Else                                        ! Right mouse button pressed
  383.           If (Mb%=2)
  384.             If (Words$(Word_index%)<>"")
  385.               Store_words$(Word_index%)=Words$(Word_index%)
  386.               Words$(Word_index%)=""                    ! Delete word
  387.               Print At(Col%,Row%);"               ";    ! Blank displayed word
  388.               Dec No_words%                             ! Decrement word count
  389.               If No_words%=0
  390.                 Words!=False
  391.                 For I%=20 To 23                        ! Disable wordlist choices
  392.                   Menu I%,2
  393.                 Next I%
  394.               Endif
  395.               Pause 6                                   ! Eliminate button bounce
  396.               Delete!=True                              ! Set delete! flag
  397.             Else
  398.               Words$(Word_index%)=Store_words$(Word_index%)
  399.               Inc No_words%
  400.               Print At(Col%,Row%);Words$(Word_index%);
  401.               Pause 6
  402.             Endif
  403.           Endif
  404.         Endif
  405.       Endif
  406.     Endif
  407.   Loop
  408.   If (Delete!=True)              ! If one or more words have been deleted,
  409.     J%=1                         ! copy word array (now containing holes)
  410.     For I%=1 To Old_no_words%    ! to temporary array.  Then recopy back,
  411.       If (Words$(I%)<>"")    ! weeding out the empty word slots
  412.         Store_words$(J%)=Words$(I%)
  413.         Inc J%
  414.       Endif
  415.     Next I%
  416.     For I%=1 To No_words%
  417.       Words$(I%)=Store_words$(I%)
  418.     Next I%
  419.   Endif
  420.   Clearw 1
  421. Return
  422. ' ******* PROCEDURE SAVE_WORDLIST **********************************************
  423. Procedure Save_wordlist
  424.   Cls
  425.   Fileselect Dir$(0)+"\*.WDS","",Temp$
  426.   If Temp$<>""
  427.     If Right$(Temp$,4)<>".WDS"
  428.       Temp$=Temp$+".WDS"
  429.     Endif
  430.     Open "O",#1,Temp$
  431.     Write #1,No_words%
  432.     For I%=1 To No_words%
  433.       Write #1,Words$(I%)
  434.     Next I%
  435.     Print At(20,6);Temp$;" has been saved on disk"
  436.     Close #1
  437.     Pause 100
  438.     Cls
  439.   Endif
  440. Return
  441. ' ******* PROCEDURE LOAD_WORDLIST *****************************************
  442. Procedure Load_wordlist
  443.   Cls
  444.   Fileselect Dir$(0)+"\*.WDS","",Temp$
  445.   If Temp$<>""
  446.     Open "I",#1,Temp$
  447.     Input #1,No_words%
  448.     Erase Words_used()
  449.     Erase Words_unused()
  450.     Dim Words_used(No_words%),Words_unused(No_words%)
  451.     For I%=1 To No_words%
  452.       Input #1,Words$(I%)
  453.     Next I%
  454.     Words!=True
  455.     Close #1
  456.     Print At(20,6);Temp$;" wordlist loaded"
  457.     Pause 100
  458.     Cls
  459.   Endif
  460. Return
  461. ' ******* PROCEDURE INIT_DIRECTIONS *************************************
  462. Procedure Init_directions
  463.   If Temp$="  Four Directions "
  464.     No_directions%=4
  465.     Restore Info4
  466.   Else
  467.     Restore Info8
  468.     No_directions%=8
  469.   Endif
  470.   ' **** Direction information for puzzle words ****
  471.   Info8:
  472.   Data 0,1, 1,1, 1,0, 1,-1, 0,-1, -1,-1, -1,0, -1,1
  473.   Info4:
  474.   Data 0,1,1,0,0,-1,-1,0
  475.   ' **** ****
  476.   Erase Ri()
  477.   Erase Ci()
  478.   Dim Ri(No_directions%),Ci(No_directions%)
  479.   For J%=1 To No_directions%
  480.     Read Ri(J%),Ci(J%)   ! Read pairs of row/col increments for directions
  481.   Next J%
  482. Return
  483. ' ******* PROCEDURE SORT_WORDS *******************************************
  484. Procedure Sort_words
  485.   Print "Sorting the word list."
  486.   For J%=1 To No_words%
  487.     Words_unused(J%)=J%
  488.   Next J%
  489.   Repeat
  490.     Sf!=False
  491.     For J%=1 To No_words%-1
  492.       If Len(Words$(Words_unused(J%)))<Len(Words$(Words_unused(J%+1)))
  493.         Swap Words_unused(J%),Words_unused(J%+1)    ! Swap words
  494.         Sf!=True               ! Set swap flag
  495.       Endif
  496.     Next J%
  497.   Until Sf!=False
  498. Return
  499. ' ******* PROCEDURE SHUFFLE_CELL_NOS  ***************************************
  500. Procedure Shuffle_cell_nos
  501.   Print "Shuffling the cell numbers."
  502.   For J%=1 To No_cells%
  503.     Sequence(J%)=0
  504.   Next J%
  505.   For J%=1 To No_cells%
  506.     Repeat
  507.       Q=Int(Rnd*No_cells%)+1
  508.     Until Sequence(Q)=0
  509.     Sequence(Q)=J%
  510.   Next J%
  511.   Arrayfill Words_used(),-1    ! Put -1 in each element of Words_used()
  512. Return
  513. ' ******** PROCEDURE BUILD_PUZZLE ******************************************
  514. Procedure Build_puzzle
  515.   If Wayflag!<>True
  516.     Gosub Init_directions
  517.   Endif
  518.   Gosub Erasegrid
  519.   Gosub Sort_words
  520.   Gosub Shuffle_cell_nos
  521.   ' **** Fill in the puzzle ****
  522.   Print "Filling in the puzzle."
  523.   Pass=1
  524.   Cell_ptr=0
  525.   Words_available=No_words%
  526.   Durection=Int(Rnd*No_directions%)+1
  527.   N1300:
  528.   Print "Pass #";Pass;"...."
  529.   ' **** Select the next cell ****
  530.   N1310:
  531.   Cell_ptr=Cell_ptr+1
  532.   Nf=1
  533.   Cp=Sequence(Cell_ptr)
  534.   Cr=Int((Cp-1)/No_cols%)+1                ! Cell row
  535.   Cc=Cp-(Cr-1)*No_cols%                    ! Cell column
  536.   If Grid$(Cr,Cc)=Space$ Or (Pass=2 And Grid$(Cr,Cc)=Crosshatch$)
  537.     Goto Check_cell_ptr
  538.   Endif
  539.   If Words_available=0
  540.     Print "Used all words"
  541.     Goto Random_fill
  542.   Endif
  543.   ' **** Select a word to put in puzzle ****
  544.   Q=1
  545.   Select_word:
  546.   W=Words_unused(Q)
  547.   W$=Words$(W)
  548.   Wl=Len(W$)
  549.   Dk=1
  550.   N1460:
  551.   Rx=Cr+(Wl-1)*Ri(Durection)
  552.   Cx=Cc+(Wl-1)*Ci(Durection)
  553.   If Rx<1 Or Rx>No_rows% Or Cx<1 Or Cx>No_cols%
  554.     Goto Sel_direction                        ! Word does not fit
  555.   Endif
  556.   ' **** Determine if word conflicts with the grid's current letters ****
  557.   Nf=0
  558.   Pr=Cr
  559.   Pc=Cc
  560.   For L=1 To Wl
  561.     T$=Grid$(Pr,Pc)
  562.     If T$=Space$
  563.       Goto N1580    ! Blank cell, word can't fit here in this direction
  564.     Endif
  565.     If T$=Crosshatch$
  566.       Goto N1600    ! Cell contains #, this letter ok, now try next letter
  567.     Endif
  568.     L$=Mid$(W$,L,1) ! L$ = Next letter of word to try
  569.     If L$=T$       ! If letter matches current cell contents
  570.       Goto N1600
  571.     Endif
  572.     N1580:
  573.     L=Wl          ! Word won't fit in this direction
  574.     Nf=1          ! Set Nofit flag
  575.     N1600:
  576.     Pr=Pr+Ri(Durection)
  577.     Pc=Pc+Ci(Durection)  ! Now try next cell/letter combination
  578.   Next L
  579.   If Nf=1
  580.     Goto Sel_direction
  581.   Endif
  582.   ' **** No conflicts found, copy the word into the puzzle grid ****
  583.   Pr=Cr
  584.   Pc=Cc
  585.   For L=1 To Wl
  586.     Grid$(Pr,Pc)=Mid$(W$,L,1)
  587.     Pr=Pr+Ri(Durection)
  588.     Pc=Pc+Ci(Durection)
  589.   Next L
  590.   If Q<>Words_available
  591.     For J%=Q To Words_available-1
  592.       Words_unused(J%)=Words_unused(J%+1)
  593.     Next J%
  594.   Endif
  595.   Dec Words_available
  596.   Words_used(W)=(Durection-1)*No_cells%+Cp-1
  597.   Inc Durection
  598.   If Durection>No_directions%
  599.     Durection=1
  600.   Endif
  601.   Goto Check_cell_ptr
  602.   ' **** Select next direction until all directions tried ****
  603.   Sel_direction:
  604.   If Dk<>No_directions%
  605.     Inc Dk
  606.     Inc Durection
  607.     If Durection>No_directions%
  608.       Durection=1
  609.     Endif
  610.     Goto N1460
  611.   Endif
  612.   If Q<>Words_available
  613.     Inc Q
  614.     Goto Select_word
  615.   Endif
  616.   Check_cell_ptr:
  617.   If Cell_ptr<>No_cells%
  618.     Goto N1310
  619.   Endif
  620.   If Pass<>2
  621.     Pass=2
  622.     Cell_ptr=0
  623.     Goto N1300
  624.   Endif
  625.   ' ******* Fill empty cells randomly to finish puzzle ********************
  626.   Random_fill:
  627.   Print "Filling in the empty cells at random"
  628.   For Cr=1 To No_rows%
  629.     For Cc=1 To No_cols%
  630.       If Grid$(Cr,Cc)=Crosshatch$
  631.         Grid$(Cr,Cc)=Chr$(Int(Rnd*26)+65)
  632.       Endif
  633.     Next Cc
  634.   Next Cr
  635.   ' **** Begin print sequence for completed puzzle ****
  636.   Print "PUZZLE COMPLETED!"
  637.   Print
  638.   Build!=True          ! Set flag to indicate puzzle now built
  639.   Gosub Print_puzzle
  640.   Ex_build:
  641. Return
  642. ' ******* PROCEDURE PRINT_PUZZLE *****************************************
  643. Procedure Print_puzzle
  644.   Gosub Select_device    ! Ask user to specify output device
  645.   Cls
  646.   Print #1,Tab(10);"FIND THE FOLLOWING HIDDEN WORDS IN THE PUZZLE:"
  647.   Print #1
  648.   Gosub Print_word_list
  649.   Gosub Print_grid
  650.   If Dv=1
  651.     Print
  652.     Print "          < TO CONTINUE: CLICK MOUSE BUTTON, OR PRESS ANY KEY >"
  653.     Repeat
  654.       Button%=Mousek
  655.       Key$=Inkey$
  656.     Until (Button%=1 Or Button%=2) Or Key$<>""
  657.   Endif
  658.   Mess$="Print|hidden|word|directory?"
  659.   Alert 2,Mess$,1,"Yes|No",D
  660.   If D=1
  661.     Gosub Print_hidden_dir
  662.   Endif
  663.   Gosub Close_device    ! Close output print device
  664.   Cls
  665.   Ex_print_puz:
  666. Return
  667. ' ******* PROCEDURE PRINT_GRID *****************************************
  668. Procedure Print_grid
  669.   Print #1
  670.   Lmargin%=Int((80-(2*No_cols%))/2)
  671.   For R%=1 To No_rows%
  672.     Print #1,Tab(Lmargin%);     ! Set left margin to center puzzle rows
  673.     For C%=1 To No_cols%-1
  674.       If Pr_flag$="pattern" And Grid$(R%,C%)<>Space$
  675.         Print #1,"#";Space$;
  676.       Else
  677.         Print #1,Grid$(R%,C%);Space$;
  678.       Endif
  679.     Next C%
  680.     If Pr_flag$="pattern" And Grid$(R%,C%)<>Space$
  681.       Print #1,"#"
  682.     Else
  683.       Print #1;Grid$(R%,C%)
  684.     Endif
  685.   Next R%
  686. Return
  687. ' ******* PROCEDURE PRINT_WORD_LIST ************************************
  688. Procedure Print_word_list
  689.   Counter%=1
  690.   For J%=1 To No_words%
  691.     If Counter%<=3
  692.       Print #1,Tab(10+((Counter%-1)*16));Words$(J%);
  693.       Inc Counter%
  694.     Else
  695.       Print #1,Tab(10+((Counter%-1)*16));Words$(J%)
  696.       Counter%=1
  697.     Endif
  698.   Next J%
  699.   Print #1
  700.   Print #1
  701. Return
  702. ' ******* PROCEDURE PRINT_HIDDEN_DIR ***********************************
  703. Procedure Print_hidden_dir
  704.   Cls
  705.   Print #1
  706.   Print #1
  707.   Print #1
  708.   Print #1
  709.   Print #1,Tab(10);"The hidden words are:"
  710.   Print #1
  711.   Print #1,Tab(10);"Word";Tab(30);"Row";Tab(36);"Col.";Tab(42);"Direction"
  712.   For J%=1 To No_words%
  713.     If Words_used(J%)<>-1
  714.       Durection=Int(Words_used(J%)/No_cells%)+1
  715.       Cp=Words_used(J%)-(Durection-1)*No_cells%+1
  716.       Cr=Int((Cp-1)/No_cols%)+1
  717.       Cc=Cp-(Cr-1)*No_cols%
  718.       If No_directions%=4 And Durection<>1
  719.         Durection=Durection*2-1  ! Adjust hidden dir printout for 4 dirs only
  720.       Endif
  721.       Print #1,Tab(10);Words$(J%);Tab(30);Cr;Tab(36);Cc;Tab(42);Durection
  722.     Endif
  723.   Next J%
  724.   Print #1
  725.   Print #1,Tab(10);"Direction      6  7  8"
  726.   Print #1,Tab(10);"Key:            \ | /"
  727.   Print #1,Tab(10);"              5 --+-- 1"
  728.   Print #1,Tab(10);"                / | \"
  729.   Print #1,Tab(10);"               4  3  2"
  730.   If Dv=1
  731.     Print
  732.     Print "          < TO CONTINUE: CLICK MOUSE BUTTON, OR PRESS ANY KEY >"
  733.     Repeat
  734.       K=Mousek
  735.       K$=Inkey$
  736.     Until (K=1 Or K=2) Or K$<>""
  737.   Endif
  738.   Cls
  739. Return
  740. ' ******* PROCEDURE SELECT_DEVICE ******************************************
  741. Procedure Select_device
  742.   Mess$="Print where?"
  743.   Alert 2,Mess$,2,"Screen|Printer",Dv
  744.   If Dv=1
  745.     Open "o",#1,"con:"
  746.   Else
  747.     Open "o",#1,"prn:"
  748.   Endif
  749. Return
  750. ' ******* PROCEDURE CLOSE_DEVICE *******************************************
  751. Procedure Close_device
  752.   Close #1
  753. Return
  754. ' ******* PROCEDURE NEW_PATTERN ******************************************
  755. Procedure New_pattern
  756.   Erase Grid$()        ! Erase all arrays
  757.   Erase Sequence()     ! to prepare for reuse
  758.   Erase Ri()
  759.   Erase Ci()
  760.   Pattern!=False        ! Set flag to indicate no pattern at present
  761.   Wayflag!=False       ! Set flag to indicate directions need reinitialize
  762.   Gosub Create_pattern
  763. Return
  764. ' ******* PROCEDURE CHG_PATTERN *****************************************
  765. Procedure Chg_pattern
  766.   Gosub Erasegrid
  767.   Build!=False      ! Force puzzle rebuild when pattern changes
  768.   Lastcol%=No_cols%*2
  769.   For Y1%=1 To No_rows%
  770.     For X1%=1 To Lastcol% Step 2
  771.       X%=Int(X1%/2)+1  ! Column position in array
  772.       If X1%<>Lastcol%
  773.         Print At(X1%,Y1%);Grid$(Y1%,X%);
  774.       Else
  775.         Print At(X1%,Y1%);Grid$(Y1%,X%)
  776.       Endif
  777.     Next X1%
  778.   Next Y1%
  779.   If No_rows%<22          ! Horizontal line below pattern
  780.     Line 0,(No_rows%*8*Rez%)+1,Lastcol%*8,(No_rows%*8*Rez%)+1
  781.   Endif
  782.   Deffill 1,2,1
  783.   If Lastcol%<79          ! Vertical line to right of pattern
  784.     Line Lastcol%*8,0,Lastcol%*8,(No_rows%*8*Rez%)+1
  785.   Endif
  786.   If Lastcol%<79
  787.     Fill Lastcol%*8+2,(Lastrow%*8*Rez%)+2  ! Darken area outside pattern
  788.   Endif
  789.   M$="Use mouse to modify pattern|-Left button erases #|-Right button fills #|-EXIT by pressing both buttons"
  790.   Alert 0,M$,1,"OK",Button%
  791.   Do
  792.     Mouse X%,Y%,Button%
  793.     Exit If Button%=3
  794.     X1%=Int(X%/8)+1     ! Column position on screen ie) double spaced etc.
  795.     Y1%=Int(Y%/(8*Rez%))+1  ! Row position on screen
  796.     X%=Int(X1%/2)+1         ! Column position in array
  797.     If X%>No_cols% Or Y1%>No_rows%
  798.       Goto Ignore
  799.     Endif
  800.     If Odd(X1%)
  801.       If Button%=2
  802.         Print At(X1%,Y1%);"#";
  803.         Grid$(Y1%,X%)="#"
  804.       Endif
  805.       If Button%=1
  806.         Print At(X1%,Y1%);" ";
  807.         Grid$(Y1%,X%)=" "
  808.       Endif
  809.     Endif
  810.     Ignore:
  811.   Loop
  812.   Cls
  813. Return
  814. ' ******* PROCEDURE PRINT_PATTERN ******************************************
  815. Procedure Print_pattern
  816.   Pr_flag$="pattern"
  817.   Gosub Select_device
  818.   Cls
  819.   Gosub Print_grid
  820.   If Dv=1
  821.     Print
  822.     Print "          < TO CONTINUE: CLICK MOUSE BUTTON, OR PRESS ANY KEY >"
  823.     Repeat
  824.       Button%=Mousek
  825.       Key$=Inkey$
  826.     Until (Button%=1 Or Button%=2) Or Key$<>""
  827.   Endif
  828.   Gosub Close_device
  829.   Cls
  830.   Pr_flag$=""
  831.   Ex_print:
  832. Return
  833. ' ******* PROCEDURE SAVE_PATTERN ********************************************
  834. Procedure Save_pattern
  835.   Cls
  836.   Fileselect Dir$(0)+"\*.PAT","",Temp$
  837.   If Temp$<>""
  838.     If Right$(Temp$,4)<>".PAT"
  839.       Temp$=Temp$+".PAT"
  840.     Endif
  841.     Open "O",#1,Temp$
  842.     Write #1,No_rows%,No_cols%,No_cells%
  843.     For R%=1 To No_rows%
  844.       For C%=1 To No_cols%
  845.         Write #1,Grid$(R%,C%)
  846.       Next C%
  847.     Next R%
  848.     Print At(20,6);Temp$;" has been saved on disk"
  849.     Close #1
  850.     Pause 100
  851.     Cls
  852.   Endif
  853.   Ex_save:
  854. Return
  855. ' ******* PROCEDURE LOAD_PATTERN  *****************************************
  856. Procedure Load_pattern
  857.   Cls
  858.   Fileselect Dir$(0)+"\*.PAT","",Temp$
  859.   If Temp$<>""
  860.     Open "I",#1,Temp$
  861.     Input #1,No_rows%,No_cols%,No_cells%
  862.     If Pattern!=True
  863.       Erase Grid$()
  864.       Erase Sequence()
  865.     Endif
  866.     Dim Grid$(No_rows%,No_cols%),Sequence(No_cells%)  ! Dimension grid
  867.     For R%=1 To No_rows%
  868.       For C%=1 To No_cols%
  869.         Input #1,Grid$(R%,C%)
  870.       Next C%
  871.     Next R%
  872.     Pattern!=True
  873.     Close #1
  874.     Print At(20,6);Temp$;" pattern loaded"
  875.     Pause 100
  876.     If Wayflag!=True
  877.       Erase Ri()          ! Allow loaded pattern to be used for
  878.       Erase Ci()          ! either 4 or 8 directions
  879.       Wayflag!=False
  880.     Endif
  881.     Cls
  882.   Endif
  883. Return
  884. ' ****** PROCEDURE BUILD_MENU_BAR *******************************************
  885. Procedure Build_menu_bar
  886.   For I%=0 To 60
  887.     Read Strip$(I%)
  888.     Exit If Strip$(I%)="***"
  889.   Next I%
  890.   Strip$(I%)=""
  891.   Strip$(I%+1)=""
  892.   Menu Strip$()
  893. Return
  894. ' ***** PROCEDURE DRAW_TITLE **************************************************
  895. Procedure Draw_title
  896.   Defline 1,3                        ! Draw frame around entire screen
  897.   Box 2,0*Rez%,637,(200*Rez%)-1
  898.   Deffill 1,2,23                     ! Draw rounded filled box in centre screen
  899.   Prbox 20,55*Rez%,620,155*Rez%
  900.   If Rez%=1
  901.     Deffill 2,2,16
  902.   Else
  903.     Deffill 1,2,16
  904.   Endif
  905.   Pcircle 180,105*Rez%,100           ! Draw filled circles centre screen
  906.   If Rez%=1
  907.     Deffill 3,2,16
  908.   Endif
  909.   Pcircle 460,105*Rez%,100
  910.   If Rez%=1
  911.     Deffill 2,2,8
  912.   Else
  913.     Deffill 1,2,8
  914.   Endif
  915.   Prbox 20,163*Rez%,620,173*Rez%     ! Draw solid fill rounded box
  916.   If Rez%=1                          ! Colour screen
  917.     Deftext 1,5,0,6
  918.   Else
  919.     Deftext 1,5,0,13                 ! Monochrome screen
  920.   Endif
  921.   Text 260,45*Rez%,"By Earl Toman"
  922.   Text 260,190*Rez%,"Press any key..."
  923.   Count=1
  924.   Colour%=1
  925.   Repeat
  926.     Deftext Colour%,13,0,32
  927.     Text 160,30*Rez%,"Word Puzzle Designer"
  928.     Pause 5
  929.     Colour%=Colour%+1
  930.     If (Rez%=2) And (Colour%=2)
  931.       Colour%=0
  932.     Else
  933.       If Rez%=1 And Colour%=4
  934.         Colour%=1
  935.       Endif
  936.     Endif
  937.     Exit If Inkey$<>""
  938.     Count=Count+1
  939.   Until Count=20
  940.   ' ***** RESTORE DEFAULTS ****************************************************
  941.   If Rez%=1
  942.     Deftext 1,0,0,6
  943.   Else
  944.     Deftext 1,0,0,13
  945.   Endif
  946.   Defline 1,1,0,0
  947. Return
  948. ' ***** DATA FOR MAIN MENU BAR **********************************************
  949. Main_menu_bar_data:
  950. Data "Desk "," Word Puzzle Designer "
  951. Data --------------------
  952. Data 1,2,3,4,5,6,""
  953. Data "Pattern "," Create "," Edit "," New "," Print "," Save "," Load ",""
  954. Data "Wordlist "," New Wordlist "," Print Wordlist "," Add Words "," Edit Wordlist "," Save Wordlist "," Load Wordlist ",""
  955. Data "Options ","  Four Directions ","  Eight Directions ",""
  956. Data "Puzzle "," Build Puzzle "," Reprint Puzzle ",""
  957. Data "Done "," Quit ",""
  958. Data ***
  959. ' ***** DATA FOR EDIT MENU BAR **********************************************
  960. Ed_menu_bar_data:
  961. Data "Desk "," Word Puzzle Designer "
  962. Data --------------------
  963. Data 1,2,3,4,5,6,""
  964. Data "Return "," Back to Main Menu ",""
  965. Data ***
  966.